#!/usr/bin/perl -w

my $usageStr = <<END_USAGE;
dv-session-server [opts] <session-cmd> [tcp-port|pipe] [--telnet/-t telnet-port]
  where [opts] is any combination of:
    --help/-h             display this help text
    --auto-exit/-x        exit after last client disconnects
    --relaunch/-r         relaunch <session-cmd> whenever it exits
  and:
    <session-cmd> is a shell command establishing a session via stdin/out,
      for example: 'netcat host 7000' or 'socat SSL:host:7000 STDIO'.
    The other arguments tell where to run raw and/or telnet servers.
    At least one of <tcp-port>, <pipe>, or <telnet-port> must be given.
END_USAGE

# A dv-session-server shares a terminal session with multiple clients.
# The terminal session is specified by an arbitrary "session command"
# naming an executable (and any needed arguments) executed in child
# whose stdio is "served" to the clients.  This was designed with Unix
# utilities like "socat" and "netcat" in mind for session commands.
#
# Two flavors of clients are supported, "raw" clients which get (and
# are expected to send) untranslated bytes, and telnet clients which
# are treated as such, and directed to go into "character at a time"
# mode, binary mode, and otherwise as appropriate for a telnet terminal
# connection.
#
# The "raw" server can bind either to a TCP port or a named pipe.
# The telnet server must bind to a TCP port.
# Either or both may be specified (but at least one must be).
#
# Each server (raw and telnet) supports multiple clients.  Currently
# there is no limit on the number of clients per port.  Standard
# output from the session command is sent immediately to all clients.
# Input from clients is sent immediately to the session command's
# standard input.  Multiple clients' input is interleaved arbitrarily
# if they are providing input concurrently.


use strict;
use warnings;

sub usage {
    my ($msg) = @_;
    print STDERR "$msg\n\n" if $msg;
    print STDERR $usageStr;
    exit 1;
}

use Socket;
use Fcntl;

use constant SIGTERM => 15;

my $optDebug;

sub dbg {
    print STDERR "DBG: ", @_, "\n" if $optDebug;
}


sub warning {
    print STDERR "WARNING: ", @_, "\n";
}


use constant SYSWRITE_ALL_WAIT_SECS => 0.01;

# Same as perl syswrite, except this detects incomplete writes (as can
# happen when a syscall is interrupted) and retries them until all
# data is written (or an error is encountered).
#
# Args: (same as Perl syswrite)
#   $handle - filehandle to be written
#   $buf    - data to be written
#   $bytes  - optional number of bytes to be written
#   $offset - optional offset within $buf to start
# Returns:
#   number of bytes actually written, or
#   undef if syswrite error (and $! set appropriately)
#
sub syswriteAll {
    my ($handle, $buf, $bytes, $offset) = @_;
    $bytes = length($buf) unless (defined $bytes);
    $offset = 0 unless (defined $offset);
    $bytes += $offset;
    while ($offset < $bytes) {
	my $n = syswrite($handle, $buf, $bytes - $offset, $offset);
	return unless (defined $n);
	$offset += $n;
	# Sleep a little if we made no progress
	select(undef, undef, undef, SYSWRITE_ALL_WAIT_SECS) unless $n;
    }
    return $bytes;
}


# Return a string representation of a binary socket address.
# Currently supporting only IP and Unix domain sockets.
# Args:
#   $sockaddr - binary socket address
# Output:
#   human-readable representation of $sockaddr
#
sub sockaddrUnparse {
    my ($sockaddr) = @_;
    my $addrFamily = sockaddr_family($sockaddr);
    if ($addrFamily == AF_INET) {
	my ($port, $ipAddrPacked) = sockaddr_in($sockaddr);
	return inet_ntoa($ipAddrPacked) . ":$port";
    } elsif ($addrFamily == AF_UNIX) {
	return unpack_sockaddr_un($sockaddr);
    } else {
	die "unrecognized address family: $addrFamily";
    }
}


# Launch session in child process, with its stdio redirected to a socketpair.
# Args:
#   $cmd - command establishing session over its stdin and stdout
# Returns:
#   the child process id and the parent filehandle to its stdio
#
sub launchSession {
    my ($cmd) = @_;

    # Create socketpair for talking to session child
    socketpair(my $childHandle, my $handle, AF_UNIX, Socket::SOCK_STREAM, 0)
	or die "socketpair: $!";
    fcntl($childHandle, Fcntl::F_SETFL, Fcntl::O_NONBLOCK) or die "fcntl: $!";
    fcntl($handle, Fcntl::F_SETFL, Fcntl::O_NONBLOCK) or die "fcntl: $!";

    # Start child process
    my $pid = fork();
    die "fork: $!" unless defined $pid;
    if ($pid) {
	# Parent returns immediately
	close($childHandle);
	dbg("launching session pid $pid: $cmd");
	return ($pid, $handle);
    }

    # Child redirects STDIN/OUT to $childHandle, then execs session cmd
    my $fd = fileno($childHandle);
    open(STDIN, "<& $fd") or die "open: $!";
    open(STDOUT, ">& $fd") or die "open: $!";
    exec(split(/ /, $cmd));
    die "exec: $!";
}


######################################################################
#		  Very Simple Telnet Server Support
######################################################################


# Telnet command prefix
use constant TELNET_CMD => 255;

# Telnet commands (that we care about)
use constant TELNET_CMD_WILL => 251;
use constant TELNET_CMD_WONT => 252;
use constant TELNET_CMD_DO => 253;
use constant TELNET_CMD_DONT => 254;

# Telnet options (that we care about; all others rejected)
use constant TELNET_OPT_BINARY => 0;
use constant TELNET_OPT_ECHO => 1;
use constant TELNET_OPT_SUPPRESS_GO_AHEAD => 3;

# Telnet options requested of other (client) side
my @telnetOptWill;
$telnetOptWill[TELNET_OPT_ECHO] = 1;
$telnetOptWill[TELNET_OPT_BINARY] = 1;
$telnetOptWill[TELNET_OPT_SUPPRESS_GO_AHEAD] = 1;

# Telnet options enabled on this (server) side
my @telnetOptDo;
$telnetOptDo[TELNET_OPT_BINARY] = 1;
$telnetOptDo[TELNET_OPT_SUPPRESS_GO_AHEAD] = 1;

sub telnetSendCmd($;$;$) {
    my ($handle, $cmd, $opt) = @_;
    syswriteAll($handle, chr(TELNET_CMD) . chr($cmd) . chr($opt))
	or die "syswrite: $!";
}

sub processTelnet {
    my ($handle, $state, $destHandle, $buf, $bytes, $offset) = @_;
    $offset = 0 unless (defined $offset);
    return $state unless $bytes > 0;
    if (! $state) {
	# Look for first NUL or TELNET_CMD
	my ($i, $ch);
	for ($i = 0; $i < $bytes; $i++) {
	    $ch = ord(substr($buf, $offset + $i, 1));
	    last if ($ch == 0 || $ch == TELNET_CMD);
	}
	# Write non-telnet data to destination handle
	syswriteAll($destHandle, $buf, $i, $offset)
	    or die "syswrite: $!";
	# Early return for most common case
	return $state if ($i == $bytes);
	# Hit a NUL or TELNET_CMD
	$state = $ch;
	# Process rest of buffer
	$offset += (++$i);
	$bytes -= $i;
	return processTelnet($handle, $state, $destHandle, $buf, $bytes, $offset);
    } elsif ($state == TELNET_CMD) {
	# next char is specific telnet command
	$state = ord(substr($buf, $offset, 1));
	# Process rest of buffer
	return processTelnet($handle, $state, $destHandle, $buf, $bytes - 1, $offset + 1);
    } else {
	# next char is telnet option
	my $opt = ord(substr($buf, $offset, 1));
	my $reply;
	# No need to respond with DO/WILL since those already sent
	if ($state == TELNET_CMD_WILL || $state == TELNET_CMD_WONT) {
	    $reply = TELNET_CMD_DONT unless $telnetOptDo[$opt];
	} elsif ($state == TELNET_CMD_DO || $state == TELNET_CMD_DONT) {
	    $reply = TELNET_CMD_WONT unless $telnetOptWill[$opt];
	} else {
	    warning("unsupported telnet cmd $state (opt $opt)");
	}
	if (defined $reply) {
	    telnetSendCmd($handle, $reply, $opt);
	}
	# Process rest of buffer - back to initial state
	return processTelnet($handle, 0, $destHandle, $buf, $bytes - 1, $offset + 1);
    }
}


######################################################################
#			    Session Server
######################################################################

# Server state:
my $sessionCmd;		# session command, from cmdline
my $tcpPort;		# tcp server port, from cmdline, if defined
my $pipename;		# server named pipe, from cmdline, if defined
my $telnetPort;		# telnet server port, from cmdline, if defined
my $optRelaunch;	# relaunch session after exit
my $optAutoExit;	# exit when last client disconnects

my $sessionPid;		# process id of session child
my $sessionHandle;	# I/O filehandle for talking to session child
my @clients;		# for each client: [ address, handle, [telnetState] ]
my $connStatus;		# string describing connection status


# Report connection status to a single client, ignoring errors
# Args:
#   $client - entry from @clients array
sub reportConnStatus {
    my ($client) = @_;
    my ($addr, $handle, $ts) = @$client;
    my $eol = defined $ts ? "\r\n" : "\n";
    syswriteAll($handle, "[$connStatus]$eol");
}


# Set connection status to given value, reporting it to all
# clients whenever it changes.
# Args:
#   $newConnStatus - new connection status string
sub setConnStatus {
    my ($newConnStatus) = @_;
    # Tell clients if connection status has changed
    if (! defined $connStatus || $connStatus ne $newConnStatus) {
	$connStatus = $newConnStatus;
	for (my $i = 0; $i < @clients; $i++) {
	    reportConnStatus($clients[$i]);
	}
    }
}

# Parse the command line
usage() unless (@ARGV > 1);
for (my $i = 0; $i < @ARGV; $i++) {
    if ($ARGV[$i] eq '--relaunch' || $ARGV[$i] eq '-r') {
	$optRelaunch = 1;
    } elsif ($ARGV[$i] eq '--auto-exit' || $ARGV[$i] eq '-x') {
	$optAutoExit = 1;
    } elsif ($ARGV[$i] eq '--help' || $ARGV[$i] eq '-h') {
	usage();
    } elsif ($ARGV[$i] eq '--telnet' || $ARGV[$i] eq '-t') {
	usage("--telnet/-t option must come after <session-cmd>") unless $sessionCmd;
	usage("--telnet/-t requires an argument") unless (++$i < @ARGV);
	if ($ARGV[$i] =~ /^\d+$/) {
	    usage("telnet-port already specified") if defined $telnetPort;
	    $telnetPort = $ARGV[$i];
	} else {
	    usage("bad telnet-port number: $ARGV[$i]")
	}
    } elsif ($ARGV[$i] eq '--debug' || $ARGV[$i] eq '-d') {
	$optDebug = 1;
    } elsif (! defined $sessionCmd) {
	$sessionCmd = $ARGV[$i];
    } else {
	usage("tcp-port already specified") if defined $tcpPort;
	usage("pipe already specified") if defined $pipename;
	if ($ARGV[$i] =~ /^\d+$/) {
	    $tcpPort = $ARGV[$i];
	} else {
	    $pipename = $ARGV[$i];
	}
    }
}


# Start raw server (if necessary)
my $tcpProtocol = getprotobyname("tcp");
if (defined $tcpPort || defined $pipename) {
    my ($pf, $protocol, $name);
    if (defined $tcpPort) {
	$pf = Socket::PF_INET;
	$protocol = $tcpProtocol;
	$name = sockaddr_in($tcpPort, INADDR_ANY);
    } else {
	$pf = Socket::PF_UNIX;
	$protocol = 0;
	(unlink($pipename) or die "unlink: $!") if -e $pipename;
	$name = sockaddr_un($pipename);
    }
    socket(RAW_SRV, $pf, Socket::SOCK_STREAM, $protocol)
	or die "socket: $!";
    setsockopt(RAW_SRV, SOL_SOCKET, SO_REUSEADDR, 1) or die "setsockopt: $!";
    bind(RAW_SRV, $name) or die "bind: $!";
    listen(RAW_SRV, SOMAXCONN) or die "listen: $!";
}


# Start telnet server (if necessary)
if (defined $telnetPort) {
    socket(TELNET_SRV, Socket::PF_INET, Socket::SOCK_STREAM, $tcpProtocol)
	or die "socket: $!";
    setsockopt(TELNET_SRV, SOL_SOCKET, SO_REUSEADDR, 1)
	or die "setsockopt: $!";
    bind(TELNET_SRV, sockaddr_in($telnetPort, INADDR_ANY)) or die "bind: $!";
    listen(TELNET_SRV, SOMAXCONN) or die "listen: $!";
}


use constant RETRY_SECS => 1.0;
use constant EXIT_WAIT_SECS => 1.0;

# Main loop:
#   monitor session, the server(s), and the client(s) for activity.
#
my $rin = "";	# bit vector of fds for select
vec($rin, fileno(TELNET_SRV), 1) = 1 if defined fileno(TELNET_SRV);
vec($rin, fileno(RAW_SRV), 1) = 1 if defined fileno(RAW_SRV);
my $timerSecs;
setConnStatus("connecting");
while (1) {

    # (Re)launch session if it doesn't exist and timer has expired
    #   (or timer doesn't exist -- as in first iteration).
    if (! defined $sessionHandle && ! $timerSecs) {
	($sessionPid, $sessionHandle) = launchSession($sessionCmd);
	vec($rin, fileno($sessionHandle), 1) = 1;
	# Now set timer to determine whether session is busy.
	$timerSecs = EXIT_WAIT_SECS;
    }

    # Wait for an event or timer expiration
    my $rout = $rin;
    (my $nr, $timerSecs) = select($rout, undef, undef, $timerSecs);

    if (defined $sessionHandle && defined $timerSecs && $timerSecs == 0) {
	# Session didn't exit within EXIT_WAIT_SECS, so declare it connected
	setConnStatus("connected");
	undef $timerSecs;
    }

    if (defined $sessionHandle && vec($rout, fileno($sessionHandle), 1)) {
	my $bytes = sysread($sessionHandle, my $buf, 4096);
	if ($bytes) {

	    # Handle output from session
	    if (defined $timerSecs) {
		# Session generated output, so declare it connected
		setConnStatus("connected");
		undef $timerSecs;
	    }
	    # Duplicate session output to all clients, ignoring errors
	    for (my $i = 0; $i < @clients; $i++) {
		syswriteAll($clients[$i]->[1], $buf, $bytes);
	    }

	} else {

	    # Session disconnected
	    vec($rin, fileno($sessionHandle), 1) = 0;
	    close($sessionHandle);
	    undef $sessionHandle;
	    waitpid($sessionPid, 0);
	    my $status = $? >> 8;
	    dbg("session exited with status $status");
	    if (defined $timerSecs) {
		setConnStatus($status ? "cannot connect" : "connection busy");
	    } else {
		setConnStatus("disconnected");
	    }
	    $timerSecs = RETRY_SECS;
	}
    }

    # If session terminated and we're not relaunching, exit now
    exit(0) unless (defined $sessionHandle || $optRelaunch);

    # Raw server socket
    if (defined fileno(RAW_SRV) && vec($rout, fileno(RAW_SRV), 1)) {
	# New raw client
	my $addr = accept(my $handle, RAW_SRV);
	if ($addr) {
	    my $fd = fileno($handle);
	    $addr = defined $tcpPort ? sockaddrUnparse($addr) : "local_$fd";
	    dbg("accepted new raw client $addr");
	    my $client = [ $addr, $handle ];
	    push(@clients, $client);
	    vec($rin, $fd, 1) = 1;
	    reportConnStatus($client);
	}
    }

    # Telnet server socket
    if (defined fileno(TELNET_SRV) && vec($rout, fileno(TELNET_SRV), 1)) {
	# new telnet client
	my $addr = accept(my $handle, TELNET_SRV);
	if ($addr) {
	    my $fd = fileno($handle);
	    $addr = sockaddrUnparse($addr);
	    dbg("accepted new telnet client $addr");
	    my $client = [ $addr, $handle, 0 ];
	    push(@clients, $client);
	    vec($rin, $fd, 1) = 1;
	    for (my $opt = 0; $opt < @telnetOptWill; $opt++) {
		telnetSendCmd($handle, TELNET_CMD_WILL, $opt) if $telnetOptWill[$opt];
	    }
	    for (my $opt = 0; $opt < @telnetOptDo; $opt++) {
		telnetSendCmd($handle, TELNET_CMD_DO, $opt) if $telnetOptDo[$opt];
	    }
	    reportConnStatus($client);
	}
    }

    # Output from clients
    for (my $i = 0; $i < @clients; $i++) {
	my $entry = $clients[$i];
	my ($addr, $handle, $ts) = @$entry;
	my $fd = fileno($handle);
	if (vec($rout, $fd, 1)) {
	    my $bytes = sysread($handle, my $buf, 4096);
	    if ($bytes) {
		if (defined $sessionHandle) {
		    if (! defined $ts) {
			# Propagate client input to session ...
			syswriteAll($sessionHandle, $buf, $bytes)
			    or die "syswrite: $!";
		    } else {
			# ... handling telnet protocol as necessary
			$$entry[2] = processTelnet($handle, $ts,
						   $sessionHandle,
						   $buf, $bytes);
		    }
		}
	    } else {
		# Client disconnected
		dbg("client " . $addr. " disconnected");
		vec($rin, $fd, 1) = 0;
		splice(@clients, $i--, 1);
		close($handle);
		if ($optAutoExit && @clients == 0) {
		    dbg("auto-exiting after last client disconnect");
		    exit(0);
		}
	    }
	}
    }
}

exit(0);

END {
    kill(SIGTERM, $sessionPid) if defined $sessionPid;
}
